home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #14
/
Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO
/
netmail
/
txtq130.zip
/
SLMRQ.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-01-26
|
8KB
|
242 lines
{$M 10240,0,655360} { 10k reserved for data }
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I- disable I/O checking (trap errors by checking IOResult)}
PROGRAM Convert_SLMR_SAV_files_to_QWK;
USES
DOS,
TXTQ;
VAR
SavedExitProc: POINTER;
{===========================================================================}
PROCEDURE CustomExit; FAR;
{---- Always exit through here ----}
BEGIN
ExitProc := SavedExitProc;
cursorOn;
Cleanup;
IF (ExitCode > 0) THEN BEGIN
WriteLn;
WriteLn ('SLMRQ - Free DOS utility: Convert SLMR .SAV text files to QWK files.');
WriteLn (author);
WriteLn;
WriteLn ('Usage: SLMRQ <SLMR .SAV file(s)> (DOS wildcards are permitted.)');
WriteLn;
WriteLn ('Example: SLMRQ startrek.sav (creates "STARTREK.Q??")');
WriteLn;
END;
IF ErrorAddr <> NIL THEN
BEGIN
WriteLn ('An unanticipated error occurred, please contact DDA with the following data:');
WriteLn ('Address = ', Seg (ErrorAddr^), ':', Ofs (ErrorAddr^));
WriteLn ('Code = ', ExitCode);
ErrorAddr := NIL;
END
ELSE
IF (ExitCode > 0) AND (ExitCode < 255) THEN
WriteErr (ExitCode);
END;
FUNCTION GetParenNum (tStr: STRING): STRING;
CONST
LParen = '(';
RParen = ')';
BEGIN
IF (Pos (LParen, tStr) > 0) THEN
Delete (tStr, 1, Pos (LParen, tStr));
IF (Pos (RParen, tStr) > 0) THEN
tStr := Copy (tStr, 1, Pos (RParen, tStr) - 1);
GetParenNum := tStr;
END;
FUNCTION GetMsgStat (CONST Status: STRING): CHAR;
(* Note: the meaning of the status flag in the header of the QWK format
specification is interpreted differently by different products.
According to Patrick Y. Lee's "QWK Mail Packet File Layout" v1.0
and Robomail v1.30, an asterisk ('*') means private and received,
and the plus sign ('+') means private and NOT received.
SLMR, OLX, and SPEED seem to agree that the meaning of the two
symbols is reversed.
Since this is a SLMR utility, I've used the latter. Thus, the private
and received flags will be translated into the following symbols:
public, unread = ' ' (#32)
public, read = '-' (#45)
private, unread = '*' (#42)
private, read = '+' (#43)
*)
CONST
Priv = '(PVT)';
YES = 'YES';
VAR MsgStat: CHAR;
BEGIN
IF (Pos (Priv, Status) > 0)
THEN
IF (Pos (YES, Status) > 0)
THEN MsgStat := #43 { private, read }
ELSE MsgStat := #42 { private, unread }
ELSE
IF (Pos (YES, Status) > 0)
THEN MsgStat := #45 { public, read }
ELSE MsgStat := #32; { public, unread }
GetMsgStat := MsgStat;
END;
FUNCTION GetConfName (ConfName: STRING): STRING;
BEGIN
IF (Pos (')', ConfName) <> 0)
THEN GetConfName := Trim (Copy (ConfName, 2 + Pos (')', ConfName), Length (ConfName)))
ELSE GetConfName := 'Unknown'
END;
FUNCTION ReadMsgheader (VAR Msgfile: FILE): STRING;
CONST
hyphens = '-------------------------------------' +
'--------------------------------------';
Msgpass = #32#32#32#32#32#32#32#32#32#32#32#32; { 12 spaces }
Msgchnk = #32#32#32#32#32#32; { 6 spaces }
VAR
Msgline: STRING;
Msgfrom, Msgto, Msgsubj: STRING [25];
Msgdate: STRING [8]; Msgtime: STRING [5];
Msgnumb: STRING [7]; Msgrfer: STRING [8];
ConfNum: STRING [5]; MsgStat: CHAR;
BEGIN
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
Verify (Msgline, 'BBS:', 2);
IF BBSname = '' THEN
BBSname := Trim (Copy (Msgline, 7, Length (Msgline)));
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
Verify (Msgline, 'Date:', 1); Msgdate := Copy (Msgline, 7, 8);
Verify (Msgline, '(', 16); Msgtime := Copy (Msgline, 17, 5);
Verify (Msgline, 'Number:',36); Msgnumb := RPad (Copy (Msgline, 44, Length (Msgline) - 43), 7, #32);
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
Verify (Msgline, 'From:', 1); Msgfrom := Copy (Msgline, 7, 25);
Verify (Msgline, 'Refer#:',36); Msgrfer := RPad (Copy (Msgline, 44, Length (Msgline) - 43), 8, #32);
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
Verify (Msgline, 'To:', 3); Msgto := Copy (Msgline, 7, 25);
Verify (Msgline, 'Recvd:', 37); MsgStat := GetMsgStat (Copy (Msgline, 44, Length (Msgline) - 43));
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
Verify (Msgline, 'Subj:', 1); Msgsubj := Copy (Msgline, 7, 25);
Verify (Msgline, 'Conf:', 38); ConfNum := StrToDoubleChar (GetParenNum (Copy (Msgline, 44, 5)));
AddConfToList (ConfNum, GetConfName (Copy (Msgline, 44, Length (Msgline))));
AddMsgToList (ConfNum, Blocks);
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb); {discard hyphen line}
Verify (Msgline, hyphens, 1);
ReadMsgheader := (MsgStat + Msgnumb + Msgdate+ MsgTime+ { 1+7+8+5 = 21 }
Msgto + Msgfrom + Msgsubj + { 25+25+25 = 75 }
Msgpass + Msgrfer + Msgchnk + #225 + { 12+8+6+1 = 27 }
ConfNum + #0#0#42); { 2+3 = 5 }
END;
{===========================================================================}
CONST
SepLine = '=====================================' +
'======================================';
VAR
Msgname: PATHSTR;
Msgext : EXTSTR;
Msgfile: FILE; DATfile : FILE;
Msgline: STRING; Message : MsgArray;
index, bytes, chunks: WORD;
Compressor : PATHSTR;
dirinfo : SEARCHREC; { contains filespec info. }
spath : PATHSTR; { source file path and }
sdir : DIRSTR; { directory }
filesdone : WORD;
BEGIN
SavedExitProc := ExitProc;
ExitProc := @CustomExit;
IF ParamCount <> 1
THEN Halt (255)
ELSE spath := GetFilePath (ParamStr (1), sDir);
FindFirst (spath, Archive, dirinfo);
filesdone := 0;
MkDir (TXTQ_DIR); CheckIO;
ChDir (TXTQ_DIR); CheckIO;
WHILE (DosError = 0) DO BEGIN
BBSname := '';
ConfList := NIL;
MsgList := NIL;
Conferences := 0;
Inc (filesdone);
Msgname := sdir + dirinfo. Name;
PrepareFiles (Msgname, Msgext, Msgfile, DATfile);
Blocks := 0;
Chunks := 2;
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
REPEAT
IF (NOT EoF (Msgfile)) AND (Msgline = SepLine) THEN BEGIN
bytes := 0; updateCursor;
Inc (Blocks, chunks);
Msgline := ReadMsgHeader (Msgfile);
REPEAT
IF (bytes < MaxBytes) THEN
bytes := AddToArray (Message, bytes, Msgline);
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
UNTIL EoF (Msgfile) OR (Msgline = SepLine);
IF EoF (Msgfile) AND (bytes < MaxBytes) THEN
bytes := AddToArray (Message, bytes, Msgline);
IF (bytes > MaxBytes) THEN bytes := MaxBytes;
WHILE (Message [bytes] = #227) AND (Message [bytes - 1] = #227) DO
Dec (bytes);
index := AddToArray (Message, 116, FigureMSGsize (bytes, chunks));
IF (chunks > 1) THEN BEGIN
FOR index := (bytes + 1) TO (chunks * 128) DO
Message [index] := #32;
END;
BlockWrite (DATfile, Message, chunks * 128); CheckIO;
END
ELSE BEGIN
ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb); {discard invalid lines}
END;
UNTIL EoF (Msgfile);
Close (Msgfile); CheckIO;
Close (DATfile); CheckIO;
WriteLn ('done!');
InitConfig (Compressor);
Write ('Compressing ', DATname, ' into ', Msgname, Msgext, ' ... ');
IF CompressDat (Msgname + Msgext, Compressor)
THEN WriteLn ('done!')
ELSE Halt (5);
FindNext (dirinfo);
END;
IF (filesdone = 0)
THEN Halt (1)
ELSE WriteLn ('Processed ', filesdone, ' file(s).');
END.